Attribute VB_Name = "Module1"
Option Explicit
Global Const MAX_SESSIONS = 5
Global AppForm(MAX_SESSIONS) As New Form1

'Global gstrErrorLogPath As String
Global gintExiting As Integer
Global gintOS As Integer
Global gbUsingPasswords As Boolean
Global gbInTrans As Boolean

Global rsRFLabel As ADODB.Recordset
Global rsRFMessage As ADODB.Recordset
Global rsRFSystemParameter As ADODB.Recordset

Global rsUsers As ADODB.Recordset
Global rsSystemParameters As ADODB.Recordset
Global dummy As Boolean
Global appUser As String


Enum enScreen
    scsplash = 1
    scLogin = 2
    scMainMenu = 3
    
    scInventory = 200
    scInventoryP1 = 201
    scInventoryP2 = 202
    scInventoryR1 = 203
    scInventoryR2 = 204
    
    scShipping = 300
    scConShip = 301
    sclshipupdate = 302
    scShippingB1 = 303
    scShippingB2 = 304
    screceiving1 = 305
    screceivingLOT = 311
    scReceiving2 = 306
    scReceiving3 = 307
    scReceiving4 = 308
    scReceiving5 = 309
    scPhysInv1 = 310
    
    scRecipe = 400
    scRecipe2 = 401
    scRecipe3 = 402
    scConfirmation = 403
    scsuccess = 404
    scFG1 = 405
    scConLot = 406
    scNoUser = 407
    scJobNumber = 408
    
      
    scReceivingB = 500
    scReceiving1b = 501
    scReceiving2b = 502
    scReceiving3b = 503
    scReceiving4b = 504
    scReceiving5b = 505
    scReceiving6b = 506
    scHAC = 507
    scconsume1 = 508
    scconsume2 = 509
    scConsume3 = 510
    'end
    
End Enum

Enum enActions
    eaOff = 0

End Enum


Sub Main()

    If App.PrevInstance Then End
    
    Dim i As Integer
    MDIForm1.Show
    
    OpenConnections
    For i = 1 To MAX_SESSIONS
        AppForm(i).Show
    Next i
    If Not MDIForm1.blnShowAll And MDIForm1.ws1 = 0 Then MDIForm1.Hide
    SetGlobals
    'App.StartLogging gstrErrorLogPath, vbLogAuto
    'MDIForm1.Caption = GetLabel("lblAppName") & " version " & App.Major & "." & App.Minor & "." & App.Revision

End Sub

Private Sub OpenConnections()
    On Error GoTo ErrorHandler
    CloseRS rsRFLabel
    CloseRS rsRFMessage
    CloseRS rsRFSystemParameter
    If Not OpenLocalConnection Then
        MsgBox "Local Database Not Found", vbCritical, "SyngisticRF"
        App.LogEvent "SyngisticRF: Local Database Not Found", vbLogEventTypeError
        gintExiting = 1
        On Error Resume Next
        'FileCopy App.Path & "\IPSRF4.bak", App.Path & "IPSRF4.mdb"
        End
    End If
    If gintExiting = 0 Then
        Set rsRFSystemParameter = New ADODB.Recordset
        rsRFSystemParameter.Open "RFSystemParameter", conLocal, adOpenKeyset, adLockReadOnly, adCmdTable
        Set rsRFLabel = New ADODB.Recordset
        rsRFLabel.Open "RFLabel", conLocal, adOpenKeyset, adLockReadOnly, adCmdTable
        Set rsRFMessage = New ADODB.Recordset
        rsRFMessage.Open "RFMessage", conLocal, adOpenKeyset, adLockReadOnly, adCmdTable
    
        'Set MDIForm1.dc = New IPSRF.MDBData
        Set MDIForm1.dc = New RF_App.MDBData
        With MDIForm1.dc
            .Provider = rsRFSystemParameter!Provider
            .Username = rsRFSystemParameter!SQLUser  'IIf(IsNull(rsRFSystemParameter!SQLUser), "", rsRFSystemParameter!SQLUser)
            .Password = rsRFSystemParameter!SQLPassword  'IIf(IsNull(rsRFSystemParameter!SQLPassword), "", rsRFSystemParameter!SQLPassword)
            .DataPath = rsRFSystemParameter!SQLDatabase
            .TrustedConnection = rsRFSystemParameter!SQLNTAuthentication
            .OpenConnections wcAll
        End With
        If Err.Number <> 0 Then
            Err.Clear
            On Error Resume Next
            MsgBox GetMessage("msgUnableToOpenConnection" & vbCrLf & _
                "provider: " & MDIForm1.dc.Provider & vbCrLf & "user: " & MDIForm1.dc.Username & vbCrLf & _
                "datapath: " & MDIForm1.dc.DataPath), vbCritical, MDIForm1.Caption
            Dim frmO As New frmOptions
            frmO.Show vbModal
            MDIForm1.clsTI.DeleteTrayIcon
            Unload frmO
            End
        End If
        Set rsSystemParameters = New ADODB.Recordset
        rsSystemParameters.Open "SystemParameters", MDIForm1.dc.conReadOnly, adOpenKeyset, adLockReadOnly, adCmdTable
        'rsSystemParameters.Open "SystemParameters", MDIForm1.dc.conReadOnly, adOpenKeyset, adLockReadOnly
        
        Set rsUsers = New ADODB.Recordset
        'rsUsers.Open "UserIDs", MDIForm1.dc.conReadOnly, adOpenKeyset, adLockReadOnly
        rsUsers.Open "UserIDs", MDIForm1.dc.conReadOnly, adOpenKeyset, adLockReadOnly, adCmdTable
        
    End If
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & ": " & Err.Source & vbCrLf & Err.Description
End Sub


Public Function GetLabel(strLabelName As String, Optional intLanguage As Integer = 99) As String
On Error Resume Next
If intLanguage = 99 Then
    intLanguage = rsRFSystemParameter!Language
End If
rsRFLabel.MoveFirst
rsRFLabel.Find ("LabelName='" & strLabelName & "'")
If Not rsRFLabel.EOF Then
    If rsRFLabel.Fields("Label" & Trim(Str(intLanguage))) = "" Then
        GetLabel = IIf(IsNull(rsRFLabel("Label0")), strLabelName, rsRFLabel("Label0"))
    Else
        GetLabel = IIf(IsNull(rsRFLabel.Fields("Label" & Trim(Str(intLanguage)))), strLabelName, rsRFLabel.Fields("Label" & Trim(Str(intLanguage))))
    End If
Else
    GetLabel = strLabelName
End If
If Err.Number <> 0 Then
    Err.Clear
    GetLabel = strLabelName
End If
End Function

Public Function GetMessage(strMessageName As String, Optional intLanguage As Integer = 99) As String
On Error Resume Next
If intLanguage = 99 Then
    intLanguage = rsRFSystemParameter!Language
End If
rsRFMessage.MoveFirst
rsRFMessage.Find ("MessageName='" & strMessageName & "'")
If Not rsRFMessage.EOF Then
    GetMessage = IIf(IsNull(rsRFMessage.Fields("Message" & Trim(Str(intLanguage)))), strMessageName, rsRFMessage.Fields("Message" & Trim(Str(intLanguage))))
Else
    GetMessage = strMessageName
End If
If Err.Number <> 0 Then
    Err.Clear
    GetMessage = strMessageName
End If
End Function

Public Function GetToolTip(strLabelName As String, Optional intLanguage As Integer = 99) As String
On Error Resume Next
If intLanguage = 99 Then
    intLanguage = rsRFSystemParameter!Language
End If
rsRFLabel.MoveFirst
rsRFLabel.Find ("LabelName='" & strLabelName & "'")
If Not rsRFLabel.EOF Then
    GetToolTip = IIf(IsNull(rsRFLabel.Fields("ToolTip" & Trim(Str(intLanguage)))), strLabelName, rsRFLabel.Fields("ToolTip" & Trim(Str(intLanguage))))
Else
    GetToolTip = strLabelName
End If
If Err.Number <> 0 Then
    Err.Clear
    GetToolTip = strLabelName
End If

End Function

Public Function GetTCPIPMessage(strLabelName As String, intLanguage As Integer) As String
  ' This function builds up the TCPIP message which is longer than the 100 character field limit
  ' in the labels table.
  Dim intCount    As Integer
  Dim strTemp     As String
  On Error Resume Next
  For intCount = 1 To 3
    rsRFLabel.MoveFirst
    rsRFLabel.Find ("LabelName='" & strLabelName & CStr(intCount) & "'")
    If Not rsRFLabel.EOF Then
      If intCount > 1 Then
        strTemp = strTemp & " "
      End If
      If rsRFLabel.Fields("Label" & Trim(Str(intLanguage))) = "" Then
        strTemp = strTemp & rsRFLabel("Label0")
      Else
        strTemp = strTemp & rsRFLabel.Fields("Label" & Trim(Str(intLanguage)))
      End If
    End If
  Next
  
  If Len(Trim(strTemp)) > 0 Then
    rsRFLabel.MoveFirst
    rsRFLabel.Find ("LabelName='" & strLabelName & "URL'")
    If Not rsRFLabel.EOF Then
      If rsRFLabel.Fields("Label" & Trim(Str(intLanguage))) = "" Then
        strTemp = strTemp & " " & rsRFLabel("Label0")
      Else
        strTemp = strTemp & " " & rsRFLabel.Fields("Label" & Trim(Str(intLanguage)))
      End If
    End If
  Else ' If not translation found then use this default.
    strTemp = "The Windows 98 TCP/IP stack may interrupt portable connections, " & _
      " discontinuing operations. An update patch is available from the Microsoft " & _
      "Online Support Site: http://support.microsoft.com/support/kb/articles/Q2365/9/26.asp."
  End If
  GetTCPIPMessage = strTemp
  If Err.Number <> 0 Then
    Err.Clear
    GetTCPIPMessage = strLabelName
  End If

End Function

Private Sub SetGlobals()
    Dim strSite As String
    Dim rsX As New ADODB.Recordset
    'gbUsingPasswords = True
    
    gbUsingPasswords = rsSystemParameters!LoginEnabled
    gintExiting = 0
    'gstrErrorLogPath = DataLoc & "\error.txt"
        
        CloseRS rsX
       
End Sub

Public Function GetCmdParameter(sParam As String, Optional vCase) As String
'This function pulls a parameter from the commandline (CmdLine$)
'This function must allow for spaces in parameters or long
'path/file names in file paths
Dim i As Integer
Dim X As String
Dim c As String

    X = Command$ & " "
    c = X
    X = UCase$(X)
    i = InStr(X, UCase$(sParam))
    If i > 0 Then
        X = Mid$(X, i - 1 + Len(sParam) + 1)
        c = Mid$(c, i - 1 + Len(sParam) + 1)
        If Mid$(X, 1, 1) = """" Then
            i = InStr(Mid$(X, 2), """")
            If i > 0 Then c = Left$(Mid$(c, 2), i - 1)
            If IsMissing(vCase) Then c = UCase$(c)
            GetCmdParameter = c
        Else
            i = InStr(X, " ")
            If i > 0 Then c = Left$(c, i - 1)
            If IsMissing(vCase) Then c = UCase$(c)
            GetCmdParameter = c
        End If
    Else
        GetCmdParameter = ""
    End If

End Function

Public Function NextTran() As String
    Dim rsX As New ADODB.Recordset
    On Error Resume Next
    rsX.Open "SELECT NextTran From rfSystemParameter", conLocal, adOpenDynamic, adLockOptimistic
    NextTran = CStr(rsX!NextTran)
    rsX!NextTran = rsX!NextTran + 1
    rsX.Update
    CloseRS rsX
    If NextTran = "" Then NextTran = "1"
End Function

Public Function FixSQLStringValue(sString As String) As String
'This function replaces "'" with "''" which are compatible with
'SQL Server

    FixSQLStringValue = Replace(sString, "'", "''")
End Function

Public Function FixDateValue(strDate As String) As String
    If strDate = "" Then
        strDate = "1/1/1920"
    End If
    FixDateValue = "#" & Format(strDate, "MM/DD/YYYY") & "#"
End Function

Public Function Logging() As Boolean
    Logging = rsSystemParameters!Logging
End Function


Public Function nz(InData As String, ReturnValue As String) As String
    If InData = "" Then
        nz = ReturnValue
    Else
        nz = InData
    End If
End Function

Public Function Center(Text As String, Optional Fill As String) As String
Dim numSpace As Integer
    If Fill = "" Then Fill = " "
    numSpace = (20 - Len(Text)) / 2
    While numSpace > 0
        Text = Fill & Text
        numSpace = numSpace - 1
        Wend
    Center = Text
    
End Function

Function Encode(OldVal As String) As String
    'this changes the password using an algorythm
    'Called for user password login
    Dim i As Integer
    Dim J As Integer
    Dim NewStr As String

    NewStr = ""
    i = Len(OldVal)
    For J = 1 To i
      NewStr = NewStr & Chr$(Asc(Mid(OldVal, J, 1)) - J * 2)
    Next J
    Encode = NewStr
End Function


Public Function InventoryTransaction(vTrans As Integer, vLot As Long, vProd As String, vQty As Double, vValue As Double, vProdType As Integer, Optional vUnitsper As String)
    'vProdType must be 1=Raw Material, 2= FG
    'vTTpype must be "1=Adjustment";"2=Receiving";"3=Usage";"4=Shipment";"5=Production"
    'vValue should be -----------?qty*price
    'vValue and VQty should be negative for usage and positive for receiving or production  -- adjustments are pos or neg
    'for FG products the lot represents the jobid
    
On Error GoTo HandleError
    Dim rsRecords As ADODB.Recordset  'tblinventory
    Dim rsRecords2 As ADODB.Recordset 'tblinventoryTransactions
    Dim vTValue As Double
    Dim vAPrice As Double
    Dim vTType As String
        
    Set rsRecords = New ADODB.Recordset
    Set rsRecords2 = New ADODB.Recordset
    Let vTValue = Abs(vQty) * vValue
    
Select Case vTrans
    Case 1
        vTType = "Adjustment"
    Case 2
        vTType = "Receiving"
    Case 3
        vTType = "Usage"
    Case 4
        vTType = "Shipment"
    Case 5
        vTType = "Production"
    Case Else
        vTType = "NA"
End Select

Select Case vProdType
    Case 1  'Raw Material or Sundry items
        rsRecords.Open "select * from tblInventory where lot = " & vLot, conLocal, adOpenDynamic, adLockOptimistic
    If rsRecords.EOF = True Then
        'Lot does not exist-- Insert new record
        rsRecords.AddNew
        rsRecords.Fields("Lot") = vLot
        rsRecords.Fields("Product") = CInt(vProd)
        rsRecords.Fields("Qty") = vQty
        rsRecords.Fields("PricePer") = vValue
        rsRecords.Fields("value") = vTValue
        rsRecords.Update
    Else
        'Lot does exist-- update quantity and value
        rsRecords.Fields("qty") = rsRecords.Fields("qty").Value + vQty
        rsRecords.Fields("value") = rsRecords.Fields("value").Value + vTValue
        rsRecords.Update
        rsRecords.Close
        
        'now update the price per unit
        rsRecords.Open "select * from tblInventory where lot = " & vLot, conLocal, adOpenDynamic, adLockOptimistic
        If rsRecords.Fields("qty").Value = 0 Or IsNull(rsRecords.Fields("qty").Value) Then
            Else
            vAPrice = rsRecords.Fields("value").Value / rsRecords.Fields("qty").Value
            rsRecords.Fields("PricePer") = vAPrice
            rsRecords.Update
        End If
        
    End If
    
Case 2 ' finished Goods

    rsRecords.Open "select * from tbljobfg where jobid = " & vLot, conLocal, adOpenDynamic, adLockOptimistic
        
    If rsRecords.EOF = True Then
        'Lot does not exist-- Insert new record
        rsRecords.AddNew
        rsRecords.Fields("jobid") = vLot
        rsRecords.Fields("UPC") = (vProd)
        rsRecords.Fields("Qty") = vQty
        rsRecords.Fields("Unitsper") = vUnitsper
        rsRecords.Fields("valueper") = vValue
        rsRecords.Fields("OnHand") = vQty
        rsRecords.Update
    Else
        'Lot does exist-- update quantity
        rsRecords.Fields("OnHand") = rsRecords.Fields("qty").Value + vQty
        rsRecords.Update
        rsRecords.Close
        
        'dont need to average the inventory value because it is set for the product.
    End If
Case Else
End Select

        'now add a transaction record
        rsRecords2.Open "select * from tblInventoryTransactions ", conLocal, adOpenDynamic, adLockOptimistic
        rsRecords2.AddNew
        rsRecords2.Fields("Lot") = vLot
        rsRecords2.Fields("TransactionType") = vTType
        rsRecords2.Fields("Qty") = Abs(vQty)
        rsRecords2.Fields("value") = Abs(vTValue)
        rsRecords2.Fields("priceper") = Abs(vValue)
        rsRecords2.Fields("user") = appUser
        rsRecords2.Update

    Set rsRecords = Nothing
    Set rsRecords2 = Nothing
    
    Exit Function

HandleError:
 MsgBox Err.Number & ": " & Err.Source & vbCrLf & Err.Description

End Function


Public Function getInventoryValue(vLot As Long)
On Error GoTo HandleError

    Dim rsRecords As ADODB.Recordset  'tblinventory
    Dim vInvVal As Double
    Set rsRecords = New ADODB.Recordset
    
    rsRecords.Open "select * from tblInventory where lot = " & vLot, conLocal, adOpenDynamic, adLockOptimistic

    Let vInvVal = rsRecords.Fields("PricePer")
    
    If IsNull(vInvVal) Then
        getInventoryValue = 0.0000000000001
    Else
        getInventoryValue = vInvVal
    End If

    rsRecords.Close

Exit Function

HandleError:
Select Case Err.Number
    Case 3021 ' no value for this product because it is not in tblInventory
        Let getInventoryValue = 0.000000000001
    Case Else
    MsgBox Err.Number & ": " & Err.Source & vbCrLf & Err.Description & vbCrLf & "Cant get inventory value -- fn getInventoryValue"
End Select

End Function




